home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / gnu_tile_forth.lha / src / forth.el < prev    next >
Lisp/Scheme  |  1992-05-19  |  27KB  |  808 lines
  1. ;; This file is part of GNU Emacs.
  2.  
  3. ;; GNU Emacs is distributed in the hope that it will be useful,
  4. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  5. ;; accepts responsibility to anyone for the consequences of using it
  6. ;; or for whether it serves any particular purpose or works at all,
  7. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  8. ;; License for full details.
  9.  
  10. ;; Everyone is granted permission to copy, modify and redistribute
  11. ;; GNU Emacs, but only under the conditions described in the
  12. ;; GNU Emacs General Public License.   A copy of this license is
  13. ;; supposed to have been given to you along with GNU Emacs so you
  14. ;; can know your rights and responsibilities.  It should be in a
  15. ;; file named COPYING.  Among other things, the copyright notice
  16. ;; and this notice must be preserved on all copies.
  17.  
  18. ;;; $Header: forth.el,v 2.10 89/12/05 mip@ida.liu.se Exp $
  19.  
  20. ;;-------------------------------------------------------------------
  21. ;; A Forth indentation, documentation search and interaction library
  22. ;;-------------------------------------------------------------------
  23. ;;
  24. ;; Written by Goran Rydqvist, gorry@ida.liu.se, Summer 1988
  25. ;; Started:    16 July 88
  26. ;; Version:    2.10
  27. ;; Last update:    5 December 1989 by Mikael Patel, mip@ida.liu.se
  28. ;; Last update:    25 June 1990 by Goran Rydqvist, gorry@ida.liu.se
  29. ;;
  30. ;; Documentation: See forth-mode (^HF forth-mode)
  31. ;;-------------------------------------------------------------------
  32.  
  33.  
  34. (defvar forth-positives
  35.   " : begin do ?do while if else case block[ does> exception> struct.type struct.init struct.does accept task.type task.body subclass method enum.type "
  36.   "Contains all words which will cause the indent-level to be incremented
  37. on the next line.
  38. OBS! All words in forth-positives must be surrounded by spaces.")
  39.  
  40. (defvar forth-negatives
  41.   " ; ]; until repeat while +loop loop else then again endcase does> exception> struct.init struct.does struct.end accept.end task.body task.end subclass.end enum.end "
  42.   "Contains all words which will cause the indent-level to be decremented
  43. on the current line.
  44. OBS! All words in forth-negatives must be surrounded by spaces.")
  45.  
  46. (defvar forth-zeroes
  47.   " : ; does> exception> struct.end task.end enum.end"
  48.   "Contains all words which causes the indent to go to zero")
  49.  
  50. (defvar forth-mode-abbrev-table nil
  51.   "Abbrev table in use in Forth-mode buffers.")
  52.  
  53. (define-abbrev-table 'forth-mode-abbrev-table ())
  54.  
  55. (defvar forth-mode-map nil
  56.   "Keymap used in Forth mode.")
  57.  
  58. (if (not forth-mode-map)
  59.     (setq forth-mode-map (make-sparse-keymap)))
  60.  
  61. (global-set-key "\e\C-m" 'forth-send-paragraph)
  62. (global-set-key "\C-x\C-m" 'forth-split)
  63. (global-set-key "\e " 'forth-reload)
  64.  
  65. (define-key forth-mode-map "\e\C-m" 'forth-send-paragraph)
  66. (define-key forth-mode-map "\eo" 'forth-send-buffer)
  67. (define-key forth-mode-map "\C-x\C-m" 'forth-split)
  68. (define-key forth-mode-map "\e " 'forth-reload)
  69. (define-key forth-mode-map "\t" 'forth-indent-command)
  70. (define-key forth-mode-map "\C-m" 'reindent-then-newline-and-indent)
  71.  
  72. (defvar forth-mode-syntax-table nil
  73.   "Syntax table in use in Forth-mode buffers.")
  74.  
  75. (if (not forth-mode-syntax-table)
  76.     (progn
  77.       (setq forth-mode-syntax-table (make-syntax-table))
  78.       (modify-syntax-entry ?\\ "\\" forth-mode-syntax-table)
  79.       (modify-syntax-entry ?/ ". 14" forth-mode-syntax-table)
  80.       (modify-syntax-entry ?* ". 23" forth-mode-syntax-table)
  81.       (modify-syntax-entry ?+ "." forth-mode-syntax-table)
  82.       (modify-syntax-entry ?- "." forth-mode-syntax-table)
  83.       (modify-syntax-entry ?= "." forth-mode-syntax-table)
  84.       (modify-syntax-entry ?% "." forth-mode-syntax-table)
  85.       (modify-syntax-entry ?< "." forth-mode-syntax-table)
  86.       (modify-syntax-entry ?> "." forth-mode-syntax-table)
  87.       (modify-syntax-entry ?& "." forth-mode-syntax-table)
  88.       (modify-syntax-entry ?| "." forth-mode-syntax-table)
  89.       (modify-syntax-entry ?\' "\"" forth-mode-syntax-table)
  90.       (modify-syntax-entry ?\t "    " forth-mode-syntax-table)
  91.       (modify-syntax-entry ?) ">   " forth-mode-syntax-table)
  92.       (modify-syntax-entry ?( "<   " forth-mode-syntax-table)
  93.       (modify-syntax-entry ?\( "()  " forth-mode-syntax-table)
  94.       (modify-syntax-entry ?\) ")(  " forth-mode-syntax-table)))
  95.  
  96. (defconst forth-indent-level 2
  97.   "Indentation of Forth statements.")
  98.  
  99. (defun forth-mode-variables ()
  100.   (set-syntax-table forth-mode-syntax-table)
  101.   (setq local-abbrev-table forth-mode-abbrev-table)
  102.   (make-local-variable 'paragraph-start)
  103.   (setq paragraph-start (concat "^$\\|" page-delimiter))
  104.   (make-local-variable 'paragraph-separate)
  105.   (setq paragraph-separate paragraph-start)
  106.   (make-local-variable 'indent-line-function)
  107.   (setq indent-line-function 'forth-indent-line)
  108.   (make-local-variable 'require-final-newline)
  109.   (setq require-final-newline t)
  110.   (make-local-variable 'comment-start)
  111.   (setq comment-start "( ")
  112.   (make-local-variable 'comment-end)
  113.   (setq comment-end " )")
  114.   (make-local-variable 'comment-column)
  115.   (setq comment-column 40)
  116.   (make-local-variable 'comment-start-skip)
  117.   (setq comment-start-skip "( ")
  118.   (make-local-variable 'comment-indent-hook)
  119.   (setq comment-indent-hook 'forth-comment-indent)
  120.   (make-local-variable 'parse-sexp-ignore-comments)
  121.   (setq parse-sexp-ignore-comments t))
  122.   
  123. (defun forth-mode ()
  124.   "
  125. Major mode for editing Forth code. Tab indents for Forth code. Comments
  126. are delimited with ( ). Paragraphs are separated by blank lines only.
  127. Delete converts tabs to spaces as it moves back.
  128. \\{forth-mode-map}
  129.  Forth-split
  130.     Positions the current buffer on top and a forth-interaction window
  131.     below. The window size is controlled by the forth-percent-height
  132.     variable (see below).
  133.  Forth-reload
  134.     Reloads the forth library and restarts the forth process.
  135.  Forth-send-buffer
  136.     Sends the current buffer, in text representation, as input to the
  137.     forth process.
  138.  Forth-send-paragraph
  139.     Sends the previous or the current paragraph to the forth-process.
  140.     Note that the cursor only need to be with in the paragraph to be sent.
  141. forth-documentation
  142.     Search for documentation of forward adjacent to cursor. Note! To use
  143.     this mode you have to add a line, to your .emacs file, defining the
  144.     directories to search through for documentation files (se variable
  145.     forth-help-load-path below) e.g. (setq forth-help-load-path '(nil)).
  146.  
  147. Variables controlling interaction and startup
  148.  forth-percent-height
  149.     Tells split how high to make the edit portion, in percent of the
  150.     current screen height.
  151.  forth-program-name
  152.     Tells the library which program name to execute in the interation
  153.     window.
  154.  
  155. Variables controlling indentation style:
  156.  forth-positives
  157.     A string containing all words which causes the indent-level of the
  158.     following line to be incremented.
  159.     OBS! Each word must be surronded by spaces.
  160.  forth-negatives
  161.     A string containing all words which causes the indentation of the
  162.     current line to be decremented, if the word begin the line. These
  163.     words also has a cancelling effect on the indent-level of the
  164.     following line, independent of position.
  165.     OBS! Each word must be surronded by spaces.
  166.  forth-zeroes
  167.     A string containing all words which causes the indentation of the
  168.     current line to go to zero, if the word begin the line.
  169.     OBS! Each word must be surronded by spaces.
  170.  forth-indent-level
  171.     Indentation increment/decrement of Forth statements.
  172.  
  173.  Note! A word which decrements the indentation of the current line, may
  174.     also be mentioned in forth-positives to cause the indentation to
  175.     resume the previous level.
  176.  
  177. Variables controling documentation search
  178.  forth-help-load-path
  179.     List of directories to search through to find *.doc
  180.     (forth-help-file-suffix) files. Nil means current default directory.
  181.     The specified directories must contain at least one .doc file. If it
  182.     does not and you still want the load-path to scan that directory, create
  183.     an empty file dummy.doc.
  184.  forth-help-file-suffix
  185.     The file names to search for in each directory specified by
  186.     forth-help-load-path. Defaulted to '*.doc'. 
  187. "
  188.   (interactive)
  189.   (kill-all-local-variables)
  190.   (use-local-map forth-mode-map)
  191.   (setq mode-name "Forth")
  192.   (setq major-mode 'forth-mode)
  193.   (forth-mode-variables)
  194.   (if (not (forth-process-running-p))
  195.       (run-forth forth-program-name))
  196.   (run-hooks 'forth-mode-hook))
  197.  
  198. (defun forth-comment-indent ()
  199.   (save-excursion
  200.     (beginning-of-line)
  201.     (if (looking-at ":[ \t]*")
  202.     (progn
  203.       (end-of-line)
  204.       (skip-chars-backward " \t\n")
  205.       (1+ (current-column)))
  206.       comment-column)))
  207.  
  208. (defun forth-current-indentation ()
  209.   (save-excursion
  210.     (beginning-of-line)
  211.     (back-to-indentation)
  212.     (current-column)))
  213.  
  214. (defun forth-delete-indentation ()
  215.   (let ((b nil) (m nil))
  216.     (save-excursion
  217.       (beginning-of-line)
  218.       (setq b (point))
  219.       (back-to-indentation)
  220.       (setq m (point)))
  221.     (delete-region b m)))
  222.  
  223. (defun forth-indent-line (&optional flag)
  224.   "Correct indentation of the current Forth line."
  225.   (let ((x (forth-calculate-indent)))
  226.     (forth-indent-to x)))
  227.   
  228. (defun forth-indent-command ()
  229.   (interactive)
  230.   (forth-indent-line t))
  231.  
  232. (defun forth-indent-to (x)
  233.   (let ((p nil))
  234.     (setq p (- (current-column) (forth-current-indentation)))
  235.     (forth-delete-indentation)
  236.     (beginning-of-line)
  237.     (indent-to x)
  238.     (if (> p 0) (forward-char p))))
  239.  
  240. ;;Calculate indent
  241. (defun forth-calculate-indent ()
  242.   (let ((w1 nil) (indent 0) (centre 0))
  243.     (save-excursion
  244.       (beginning-of-line)
  245.       (skip-chars-backward " \t\n")
  246.       (beginning-of-line)
  247.       (back-to-indentation)
  248.       (setq indent (current-column))
  249.       (setq centre indent)
  250.       (setq indent (+ indent (forth-sum-line-indentation))))
  251.     (save-excursion
  252.       (beginning-of-line)
  253.       (back-to-indentation)
  254.       (let ((p (point)))
  255.     (skip-chars-forward "^ \t\n")
  256.     (setq w1 (buffer-substring p (point)))))
  257.     (if (> (- indent centre) forth-indent-level)
  258.     (setq indent (+ centre forth-indent-level)))
  259.     (if (> (- centre indent) forth-indent-level)
  260.     (setq indent (- centre forth-indent-level)))
  261.     (if (< indent 0) (setq indent 0))
  262.     (setq indent (- indent
  263.             (if (string-match 
  264.              (regexp-quote (concat " " w1 " "))
  265.              forth-negatives)
  266.             forth-indent-level 0)))
  267.     (if (string-match (regexp-quote (concat " " w1 " ")) forth-zeroes)
  268.     (setq indent 0))
  269.     indent))
  270.  
  271. (defun forth-sum-line-indentation ()
  272.   "Add upp the positive and negative weights of all words on the current line."
  273.   (let ((b (point)) (e nil) (sum 0) (w nil) (t1 nil) (t2 nil) (first t))
  274.     (end-of-line) (setq e (point))
  275.     (goto-char b)
  276.     (while (< (point) e)
  277.       (setq w (forth-next-word))
  278.       (setq t1 (string-match (regexp-quote (concat " " w " "))
  279.                  forth-positives))
  280.       (setq t2 (string-match (regexp-quote (concat " " w " "))
  281.                  forth-negatives))
  282.       (if (and t1 t2)
  283.       (setq sum (+ sum forth-indent-level)))
  284.       (if t1
  285.       (setq sum (+ sum forth-indent-level)))
  286.       (if (and t2 (not first))
  287.       (setq sum (- sum forth-indent-level)))
  288.       (skip-chars-forward " \t")
  289.       (setq first nil))
  290.     sum))
  291.  
  292.  
  293. (defun forth-next-word ()
  294.   "Return the next forth-word. Skip anything enclosed in double quotes or ()."
  295.   (let ((w1 nil))
  296.     (while (not w1)
  297.       (skip-chars-forward " \t\n")
  298.       (let ((p (point)))
  299.     (skip-chars-forward "^ \t\n")
  300.     (setq w1 (buffer-substring p (point))))
  301.       (cond ((string-match "\"" w1)
  302.          (progn
  303.            (skip-chars-forward "^\"")
  304.            (setq w1 nil)))
  305.         ((string-match "\(" w1)
  306.          (progn
  307.            (skip-chars-forward "^\)")
  308.            (setq w1 nil)))
  309.         (t nil)))
  310.     w1))
  311.       
  312.  
  313. ;; Forth commands
  314.  
  315. (defvar forth-program-name "forth"
  316.   "*Program invoked by the `run-forth' command.")
  317.  
  318. (defvar forth-band-name nil
  319.   "*Band loaded by the `run-forth' command.")
  320.  
  321. (defvar forth-program-arguments nil
  322.   "*Arguments passed to the Forth program by the `run-forth' command.")
  323.  
  324. (defun run-forth (command-line)
  325.   "Run an inferior Forth process. Output goes to the buffer `*forth*'.
  326. With argument, asks for a command line. Split up screen and run forth 
  327. in the lower portion. The current-buffer when called will stay in the
  328. upper portion of the screen, and all other windows are deleted.
  329. Call run-forth again to make the *forth* buffer appear in the lower
  330. part of the screen."
  331.   (interactive
  332.    (list (let ((default
  333.          (or forth-process-command-line
  334.              (forth-default-command-line))))
  335.        (if current-prefix-arg
  336.            (read-string "Run Forth: " default)
  337.            default))))
  338.   (setq forth-process-command-line command-line)
  339.   (forth-start-process command-line)
  340.   (forth-split)
  341.   (forth-set-runlight forth-runlight:input))
  342.  
  343. (defun reset-forth ()
  344.   "Reset the Forth process."
  345.   (interactive)
  346.   (let ((process (get-process forth-program-name)))
  347.     (cond ((or (not process)
  348.            (not (eq (process-status process) 'run))
  349.            (yes-or-no-p
  350. "The Forth process is running, are you SURE you want to reset it? "))
  351.        (message "Resetting Forth process...")
  352.        (forth-reload)
  353.        (message "Resetting Forth process...done")))))
  354.  
  355. (defun forth-default-command-line ()
  356.   (concat forth-program-name " -emacs"
  357.       (if forth-program-arguments
  358.           (concat " " forth-program-arguments)
  359.           "")
  360.       (if forth-band-name
  361.           (concat " -band " forth-band-name)
  362.           "")))
  363.  
  364. ;;;; Internal Variables
  365.  
  366. (defvar forth-process-command-line nil
  367.   "Command used to start the most recent Forth process.")
  368.  
  369. (defvar forth-previous-send ""
  370.   "Most recent expression transmitted to the Forth process.")
  371.  
  372. (defvar forth-process-filter-queue '()
  373.   "Queue used to synchronize filter actions properly.")
  374.  
  375. (defvar forth-prompt "ok"
  376.   "The current forth prompt string.")
  377.  
  378. (defvar forth-start-hook nil
  379.   "If non-nil, a procedure to call when the Forth process is started.
  380. When called, the current buffer will be the Forth process-buffer.")
  381.  
  382. (defvar forth-signal-death-message nil
  383.   "If non-nil, causes a message to be generated when the Forth process dies.")
  384.  
  385. (defvar forth-percent-height 62
  386.   "Tells run-forth how high the upper window should be in percent.")
  387.  
  388. (defconst forth-runlight:input ?I
  389.   "The character displayed when the Forth process is waiting for input.")
  390.  
  391. (defvar forth-mode-string ""
  392.   "String displayed in the mode line when the Forth process is running.")
  393.  
  394. ;;;; Evaluation Commands
  395.  
  396. (defun forth-send-string (&rest strings)
  397.   "Send the string arguments to the Forth process.
  398. The strings are concatenated and terminated by a newline."
  399.   (cond ((forth-process-running-p)
  400.      (forth-send-string-1 strings))
  401.     ((yes-or-no-p "The Forth process has died.  Reset it? ")
  402.      (reset-forth)
  403.      (goto-char (point-max))
  404.      (forth-send-string-1 strings))))
  405.  
  406. (defun forth-send-string-1 (strings)
  407.   (let ((string (apply 'concat strings)))
  408.     (forth-send-string-2 string)))
  409.  
  410. (defun forth-send-string-2 (string)
  411.   (let ((process (get-process forth-program-name)))
  412.     (if (not (eq (current-buffer) (get-buffer forth-program-name)))
  413.     (progn
  414.      (forth-process-filter-output string)
  415.      (forth-process-filter:finish)))
  416.     (send-string process (concat string "\n"))
  417.     (if (eq (current-buffer) (process-buffer process))
  418.     (set-marker (process-mark process) (point)))))
  419.  
  420.  
  421. (defun forth-send-region (start end)
  422.   "Send the current region to the Forth process.
  423. The region is sent terminated by a newline."
  424.   (interactive "r")
  425.   (let ((process (get-process forth-program-name)))
  426.     (if (and process (eq (current-buffer) (process-buffer process)))
  427.     (progn (goto-char end)
  428.            (set-marker (process-mark process) end))))
  429.   (forth-send-string "\n" (buffer-substring start end) "\n"))
  430.  
  431. (defun forth-end-of-paragraph ()
  432.   (if (looking-at "[\t\n ]+") (skip-chars-backward  "\t\n "))
  433.   (if (not (re-search-forward "\n[ \t]*\n" nil t))
  434.       (goto-char (point-max))))
  435.  
  436. (defun forth-send-paragraph ()
  437.   "Send the current or the previous paragraph to the Forth process"
  438.   (interactive)
  439.   (let (end)
  440.     (save-excursion
  441.       (forth-end-of-paragraph)
  442.       (skip-chars-backward  "\t\n ")
  443.       (setq end (point))
  444.       (if (re-search-backward "\n[ \t]*\n" nil t)
  445.       (setq start (point))
  446.     (goto-char (point-min)))
  447.       (skip-chars-forward  "\t\n ")
  448.       (forth-send-region (point) end))))
  449.   
  450. (defun forth-send-buffer ()
  451.   "Send the current buffer to the Forth process."
  452.   (interactive)
  453.   (if (eq (current-buffer) (forth-process-buffer))
  454.       (error "Not allowed to send this buffer's contents to Forth"))
  455.   (forth-send-region (point-min) (point-max)))
  456.  
  457.  
  458. ;;;; Basic Process Control
  459.  
  460. (defun forth-start-process (command-line)
  461.   (let ((buffer (get-buffer-create "*forth*")))
  462.     (let ((process (get-buffer-process buffer)))
  463.       (save-excursion
  464.     (set-buffer buffer)
  465.     (progn (if process (delete-process process))
  466.            (goto-char (point-max))
  467.            (setq mode-line-process '(": %s"))
  468.            (add-to-global-mode-string 'forth-mode-string)
  469.            (setq process
  470.              (apply 'start-process
  471.                 (cons forth-program-name
  472.                   (cons buffer
  473.                     (forth-parse-command-line
  474.                      command-line)))))
  475.            (set-marker (process-mark process) (point-max))
  476.            (forth-process-filter-initialize t)
  477.            (forth-modeline-initialize)
  478.            (set-process-sentinel process 'forth-process-sentinel)
  479.            (set-process-filter process 'forth-process-filter)
  480.            (run-hooks 'forth-start-hook)))
  481.     buffer)))
  482.  
  483. (defun forth-parse-command-line (string)
  484.   (setq string (substitute-in-file-name string))
  485.   (let ((start 0)
  486.     (result '()))
  487.     (while start
  488.       (let ((index (string-match "[ \t]" string start)))
  489.     (setq start
  490.           (cond ((not index)
  491.              (setq result
  492.                (cons (substring string start)
  493.                  result))
  494.              nil)
  495.             ((= index start)
  496.              (string-match "[^ \t]" string start))
  497.             (t
  498.              (setq result
  499.                (cons (substring string start index)
  500.                  result))
  501.              (1+ index))))))
  502.     (nreverse result)))
  503.  
  504.  
  505. (defun forth-process-running-p ()
  506.   "True iff there is a Forth process whose status is `run'."
  507.   (let ((process (get-process forth-program-name)))
  508.     (and process
  509.      (eq (process-status process) 'run))))
  510.  
  511. (defun forth-process-buffer ()
  512.   (let ((process (get-process forth-program-name)))
  513.     (and process (process-buffer process))))
  514.  
  515. ;;;; Process Filter
  516.  
  517. (defun forth-process-sentinel (proc reason)
  518.   (let ((inhibit-quit nil))
  519.     (forth-process-filter-initialize (eq reason 'run))
  520.     (if (eq reason 'run)
  521.     (forth-modeline-initialize)
  522.     (setq forth-mode-string "")))
  523.   (if (and (not (memq reason '(run stop)))
  524.        forth-signal-death-message)
  525.       (progn (beep)
  526.          (message
  527. "The Forth process has died!  Do M-x reset-forth to restart it"))))
  528.  
  529. (defun forth-process-filter-initialize (running-p)
  530.   (setq forth-process-filter-queue (cons '() '()))
  531.   (setq forth-prompt "ok"))
  532.  
  533.  
  534. (defun forth-process-filter (proc string)
  535.   (forth-process-filter-output string)
  536.   (forth-process-filter:finish))
  537.  
  538. (defun forth-process-filter:enqueue (action)
  539.   (let ((next (cons action '())))
  540.     (if (cdr forth-process-filter-queue)
  541.     (setcdr (cdr forth-process-filter-queue) next)
  542.     (setcar forth-process-filter-queue next))
  543.     (setcdr forth-process-filter-queue next)))
  544.  
  545. (defun forth-process-filter:finish ()
  546.   (while (car forth-process-filter-queue)
  547.     (let ((next (car forth-process-filter-queue)))
  548.       (setcar forth-process-filter-queue (cdr next))
  549.       (if (not (cdr next))
  550.       (setcdr forth-process-filter-queue '()))
  551.       (apply (car (car next)) (cdr (car next))))))
  552.  
  553. ;;;; Process Filter Output
  554.  
  555. (defun forth-process-filter-output (&rest args)
  556.   (if (not (and args
  557.         (null (cdr args))
  558.         (stringp (car args))
  559.         (string-equal "" (car args))))
  560.       (forth-process-filter:enqueue
  561.        (cons 'forth-process-filter-output-1 args))))
  562.  
  563. (defun forth-process-filter-output-1 (&rest args)
  564.   (save-excursion
  565.     (forth-goto-output-point)
  566.     (apply 'insert-before-markers args)))
  567.  
  568. (defun forth-guarantee-newlines (n)
  569.   (save-excursion
  570.     (forth-goto-output-point)
  571.     (let ((stop nil))
  572.       (while (and (not stop)
  573.           (bolp))
  574.     (setq n (1- n))
  575.     (if (bobp)
  576.         (setq stop t)
  577.       (backward-char))))
  578.     (forth-goto-output-point)
  579.     (while (> n 0)
  580.       (insert-before-markers ?\n)
  581.       (setq n (1- n)))))
  582.  
  583. (defun forth-goto-output-point ()
  584.   (let ((process (get-process forth-program-name)))
  585.     (set-buffer (process-buffer process))
  586.     (goto-char (process-mark process))))
  587.  
  588. (defun forth-modeline-initialize ()
  589.   (setq forth-mode-string "  "))
  590.  
  591. (defun forth-set-runlight (runlight)
  592.   (aset forth-mode-string 0 runlight)
  593.   (forth-modeline-redisplay))
  594.  
  595. (defun forth-modeline-redisplay ()
  596.   (save-excursion (set-buffer (other-buffer)))
  597.   (set-buffer-modified-p (buffer-modified-p))
  598.   (sit-for 0))
  599.  
  600. ;;;; Process Filter Operations
  601.  
  602. (defun add-to-global-mode-string (x)
  603.   (cond ((null global-mode-string)
  604.      (setq global-mode-string (list "" x " ")))
  605.     ((not (memq x global-mode-string))
  606.      (setq global-mode-string
  607.            (cons ""
  608.              (cons x
  609.                (cons " "
  610.                  (if (equal "" (car global-mode-string))
  611.                      (cdr global-mode-string)
  612.                      global-mode-string))))))))
  613.  
  614.  
  615. ;; Misc
  616.  
  617. (setq auto-mode-alist (append auto-mode-alist
  618.                 '(("\\.f83$" . forth-mode))))
  619.  
  620. (defun forth-split ()
  621.   (interactive)
  622.   (forth-split-1 "*forth*"))
  623.  
  624. (defun forth-split-1 (buffer)
  625.   (if (not (eq (window-buffer) (get-buffer buffer)))
  626.       (progn
  627.     (delete-other-windows)
  628.     (split-window-vertically
  629.      (/ (* (screen-height) forth-percent-height) 100))
  630.     (other-window 1)
  631.     (switch-to-buffer buffer)
  632.     (goto-char (point-max))
  633.     (other-window 1))))
  634.     
  635. (defun forth-reload ()
  636.   (interactive)
  637.   (let ((process (get-process forth-program-name)))
  638.     (if process (kill-process process t)))
  639.   (sleep-for-millisecs 100)
  640.   (forth-mode))
  641.  
  642.  
  643. ;; Special section for forth-help
  644.  
  645. (defvar forth-help-buffer "*Forth-help*"
  646.   "Buffer used to display the requested documentation.")
  647.  
  648. (defvar forth-help-load-path nil
  649.   "List of directories to search through to find *.doc
  650.  (forth-help-file-suffix) files. Nil means current default directory.
  651.  The specified directories must contain at least one .doc file. If it
  652.  does not and you still want the load-path to scan that directory, create
  653.  an empty file dummy.doc.")
  654.  
  655. (defvar forth-help-file-suffix "*.doc"
  656.   "The file names to search for in each directory.")
  657.  
  658. (setq forth-search-command-prefix "grep -n \"^    [^(]* ")
  659. (defvar forth-search-command-suffix "/dev/null")
  660. (defvar forth-grep-error-regexp ": No such file or directory")
  661.  
  662. (defun forth-function-called-at-point ()
  663.   "Return the space delimited word a point."
  664.   (save-excursion
  665.     (save-restriction
  666.       (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
  667.       (skip-chars-backward "^ \t\n" (point-min))
  668.       (if (looking-at "[ \t\n]")
  669.       (forward-char 1))
  670.       (let (obj (p (point)))
  671.     (skip-chars-forward "^ \t\n")
  672.     (buffer-substring p (point))))))
  673.  
  674. (defun forth-help-names-extend-comp (path-list result)
  675.   (cond ((null path-list) result)
  676.     ((null (car path-list))
  677.      (forth-help-names-extend-comp (cdr path-list) 
  678.            (concat result forth-help-file-suffix " ")))
  679.     (t (forth-help-names-extend-comp
  680.         (cdr path-list) (concat result
  681.                     (expand-file-name (car path-list)) "/"
  682.                     forth-help-file-suffix " ")))))
  683.  
  684. (defun forth-help-names-extended ()
  685.   (if forth-help-load-path
  686.       (forth-help-names-extend-comp forth-help-load-path "")
  687.     (error "forth-help-load-path not specified")))
  688.  
  689.  
  690. (define-key forth-mode-map "\C-hf" 'forth-documentation)
  691.  
  692. (defun forth-documentation (function)
  693.   "Display the full documentation of FORTH word."
  694.   (interactive
  695.    (let ((fn (forth-function-called-at-point))
  696.      (enable-recursive-minibuffers t)         
  697.      search-list
  698.      val)
  699.      (setq val (read-string (format "Describe forth word (default %s): " fn)))
  700.      (list (if (equal val "") fn val))))
  701.   (forth-get-doc (concat forth-search-command-prefix
  702.              (grep-regexp-quote (concat function " ("))
  703.              "[^)]*\-\-\" " (forth-help-names-extended)
  704.              forth-search-command-suffix))
  705.   (message "C-x C-m switches back to the forth interaction window"))
  706.  
  707. (defun forth-get-doc (command)
  708.   "Display the full documentation of command."
  709.   (let ((curwin (get-buffer-window (window-buffer)))
  710.     reswin
  711.     pointmax)
  712.     (with-output-to-temp-buffer forth-help-buffer
  713.       (progn
  714.     (call-process "sh" nil forth-help-buffer t "-c" command)
  715.     (setq reswin (get-buffer-window forth-help-buffer))))
  716.     (setq reswin (get-buffer-window forth-help-buffer))
  717.     (select-window reswin)
  718.     (save-excursion
  719.       (goto-char (setq pointmax (point-max)))
  720.       (insert "--------------------\n\n"))
  721.     (let (fd doc) 
  722.       (while (setq fd (forth-get-file-data pointmax))
  723.     (setq doc (forth-get-doc-string fd))
  724.     (save-excursion
  725.       (goto-char (point-max))
  726.       (insert (substring (car fd) (string-match "[^/]*$" (car fd)))
  727.           ":\n\n" doc "\n")))
  728.       (if (not doc)
  729.       (progn (goto-char (point-max)) (insert "Not found"))))
  730.     (select-window curwin)))
  731.   
  732. (defun forth-skip-error-lines ()
  733.   (let ((lines 0))
  734.     (save-excursion
  735.       (while (re-search-forward forth-grep-error-regexp nil t)
  736.     (beginning-of-line)
  737.     (forward-line 1)
  738.     (setq lines (1+ lines))))
  739.     (forward-line lines)))
  740.  
  741. (defun forth-get-doc-string (fd)
  742.   "Find file (car fd) and extract documentation from line (nth 1 fd)."
  743.   (let (result)
  744.     (save-window-excursion
  745.       (find-file (car fd))
  746.       (goto-line (nth 1 fd))
  747.       (if (not (eq (nth 1 fd) (1+ (count-lines (point-min) (point)))))
  748.       (error "forth-get-doc-string: serious error"))
  749.       (if (not (re-search-backward "\n[\t ]*\n" nil t))
  750.       (goto-char (point-min))
  751.     (goto-char (match-end 0)))
  752.       (let ((p (point)))
  753.     (if (not (re-search-forward "\n[\t ]*\n" nil t))
  754.         (goto-char (point-max)))
  755.     (setq result (buffer-substring p (point))))
  756.       (bury-buffer (current-buffer)))
  757.     result))
  758.  
  759. (defun forth-get-file-data (limit)
  760.   "Parse grep output and return '(filename line#) list. Return nil when
  761.  passing limit."
  762.   (forth-skip-error-lines)
  763.   (if (< (point) limit)
  764.       (let ((result (forth-get-file-data-cont limit)))
  765.     (forward-line 1)
  766.     (beginning-of-line)
  767.     result)))
  768.  
  769. (defun forth-get-file-data-cont (limit)
  770.   (let (result)
  771.     (let ((p (point)))
  772.       (skip-chars-forward "^:")
  773.       (setq result (buffer-substring p (point))))
  774.     (if (< (point) limit)
  775.     (let ((p (1+ (point))))
  776.       (forward-char 1)
  777.       (skip-chars-forward "^:")
  778.       (list result (string-to-int (buffer-substring p (point))))))))
  779.  
  780. (defun grep-regexp-quote (str)
  781.   (let ((i 0) (m 1) (res ""))
  782.     (while (/= m 0)
  783.       (setq m (string-to-char (substring str i)))
  784.       (if (/= m 0)
  785.       (progn
  786.         (setq i (1+ i))
  787.         (if (string-match (regexp-quote (char-to-string m))
  788.                   ".*\\^$[]")
  789.         (setq res (concat res "\\")))
  790.         (setq res (concat res (char-to-string m))))))
  791.     res))
  792.  
  793.  
  794. (define-key forth-mode-map "\C-x\C-e" 'forth-compile)
  795. (define-key forth-mode-map "\C-x\C-n" 'next-error)
  796. (require 'compile "compile")
  797.  
  798. (defvar forth-compile-command "forth ")
  799. (defvar forth-compilation-window-percent-height 30)
  800.  
  801. (defun forth-compile (command)
  802.   (interactive (list (setq forth-compile-command (read-string "Compile command: " forth-compile-command))))
  803.   (forth-split-1 "*compilation*")
  804.   (setq ctools-compile-command command)
  805.   (compile1 ctools-compile-command "No more errors"))
  806.  
  807.  
  808.